﻿{-# OPTIONS_GHC -XRecordWildCards -XNamedFieldPuns #-}
module XI.Directory.Parser where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(haskellDef)
import XI.Directory.Types
import Data.Maybe
import Data.List
import Data.Ord(comparing)

parseDir :: Parser Configuration
parseDir = do {
      whiteSpace;	x<-do {
        zc<-lexeme $ many $ do {
          s<-option Nothing $ reserved "BEGIN" >> identifier >>= return . Just;
          chains<-many1 $ do {
            bss<-system; ccs<-lexeme $ identifier <|> string "-"; mis<-uri;  reservedOp "=>";
            rcvs<-many1 $ do {
              cond<-condition; bs<-system; 
              rints<-many1 $ do {
                mi<-uri; im<-lexeme $ string "-" <|> uri; ccr<-lexeme $ identifier <|>string "-"; icond<-condition; 
                            return RcvInt { 
                                    ri_cond = getMb Condition icond, 
                                    r_int = mi, 
                                    mapping = getMb id im, 
                                    r_cc = ccr,
                                    r_params = Nothing,
                                    r_cc_params = Nothing,
                                    r_descriptions = ("", "")
                                }
              }; 
              return Receiver {r_cond = getMb Condition cond, r_sys = bs, r_description = "", r_ints = rints}
            };
            return Chain {
                    chain_sender = Sender {
                            s_sys = bss, 
                            s_cc = ccs, 
                            s_int = mis, 
                            s_params = Nothing, 
                            s_cc_params = Nothing, 
                            s_descriptions = ("","")
                        },
                    chain_description = "", 
                    chain_receivers = rcvs
                }
          };
          if s == Nothing then return () else reserved "END";
          return Scenario { scenario_name = s,
                            scenario_chains = chains,
                            scenario_description = "",
                            scenario_notes = Nothing }
        };
        zu<-lexeme $ many (do { 
          (lexeme $ do {reserved "+CC"; s<-system; cc<-identifier; t<-getType; at<-adapterType;
                        return CC {	
                                cc_system = s,
                                cc_name = cc,
                                cc_description = "",
                                cc_param = (t, at),
                                cc_param_map = Nothing } 
                            }) <|>
          (lexeme $ do {reserved "+Sc"; sc<-identifier; xx<-squares $ many $ lexeme $ scid; 
                return Sc {	sc_name = sc,
                            sc_description = "",
                            sc_ids = xx }}) <|>
          (lexeme $ do {reserved "+Agg"; t<-getType; 
            ss <- if t == CCSender then return defXISystem else system_def;
            s <- system; mi <- lexeme $ uri <|> string "*/*"; cc <- identifier;  
            return $ if t == CCSender then SAgg { sender = s,
                                                  sender_int = mi,
                                                  sa_description = "",
                                                  sender_cc = cc } 
                                      else RAgg { sender = ss,
                                                  receiver = s,
                                                  ra_description = "",
                                                  receiver_int = mi,
                                                  receiver_cc = cc } }) <|>
          (lexeme $ do {reserved "+RD"; s <- system; mi <- uri; ss <- many1 $ 
            do {cond <- condition; i <- system; return (getMb Condition cond, i)}; 
              return RD { sender = s,
                          sender_int = mi,
                          rd_description = "",
                          cond_receivers = ss }}) <|>
          (lexeme $ do {reserved "+ID"; s <- system_def; mi <- uri; r <- system_def; 
            ss <- many1 $ do {cond <- condition; u <- uri; m <- lexeme $ string "-" <|> uri; return (getMb Condition cond, u, getMb id m)};
            return ID {	sender = s,
                        sender_int = mi,
                        id_description = "",
                        receiver = r,
                        cond_receiver_ints = ss } })
        });
        sccs<-lexeme $ many $ lexeme $ do {string "+"; s <- system; many1 $ do {cc <- identifier; t <- getType; at <- adapterType; 
            return CC {	cc_system = s,
                        cc_name = cc,
                        cc_description = "",
                        cc_param = (t, at),
                        cc_param_map = Nothing }}};
        ips <- lexeme $ reserved "[IntegrationProcesses]" >> (lexeme $ many $ lexeme $ system >>= return . flip IP "");
        return (nub zc, nub zu ++ (concat sccs) ++ ips);
      }; eof; return x;
    }
    where 
        getMb f x = if x == "-" then Nothing else Just $ f x
        getType = (reserved "S" >> return CCSender) <|> (reserved "R" >> return CCReceiver)
        whiteSpace= P.whiteSpace lexer
        squares = P.squares lexer
        lexeme = P.lexeme lexer
        identifier= P.identifier lexer
        reserved = P.reserved lexer
        reservedOp= P.reservedOp lexer

        uri = lexeme $ do 
          s0 	<- string "http://" <|> string "urn:"
          s 	<- many1 (letter <|> digit <|> oneOf "_-./:") <?> "uri" 
          return $ s0 ++ s
          
        condition = lexeme (string "-" <?> "condition")
        scid = lexeme (many1 (letter <|> digit <|> oneOf "|_./:-*") <?> "scenario object id (scid)")
        adapterType = (identifier >>= return . readAT) <?> 
                "adapterType (JMS | JDBC | File | FTP | RFC | IDoc | HTTP | XI | SOAP | RNIF | CIDX | Mail | Marketplace | BC)"

        lexer = P.makeTokenParser $ haskellDef {P.reservedNames = ["BEGIN","END", "+CC", "+Sc", "+Agg", "+RD", "+ID", "[IntegrationProcesses]", "S", "R"]}
        system = lexeme (do { p <- identifier; string "|"; s <- identifier; return $ XISystem (Just p) s } <|> (identifier >>= return . XISystem Nothing))
             <?> "party|system or system"
        system_def = lexeme (system <|> (string "*" >> return defXISystem)) <?> "party|system or system or *";

        
        
scriptDir::Configuration->[String]
scriptDir (scs, xos) = 
  ["-- chains", ""] ++
  concatMap fsc scs ++ 
  ["", "", "-- unchained", ""] ++
  (map (('+':) . show) $ filter (not . flip any [isCC, isIP] . flip ($)) xos) ++ 
  ["", "", "-- communication channels", ""] ++
  (concatMap fcch $ foldr foldcch [] $ sortBy (comparing cc_system) $ filter isCC xos) ++ 
  ["", "", "[IntegrationProcesses]", ""] ++
    (map ((drop 3) . show) $ filter isIP xos)
  where 
    fsc (Scenario sc _ chains _) = 
      (if sc == Nothing then [] else ["BEGIN " ++ (fromJust sc)]) ++
      (concat $ map (fch $ sc /= Nothing) chains) ++
      (if sc == Nothing then ["\n"] else ["END\n"])
    fch isShift (Chain sender _ receivers) = (fsender isShift sender) ++ (concatMap (frcv isShift) receivers)
    fsender isShift (Sender sys cc int _ _ _) = [shift isShift ++ show sys ++ " " ++ cc ++ " " ++ int ++ " => "]
    frcv isShift (Receiver cond sys _ ints) = 
      [shift isShift ++ "\t" ++ showCond cond ++ " " ++ show sys] ++
      (concat $ map (frint isShift) ints)
    frint isShift (RcvInt cond int m cc _ _ _) = [shift isShift ++ "\t\t" ++ int ++ " " ++ 
      fromMaybe "-" m ++ " " ++ cc ++ " " ++ showCond cond]
    showCond c = if c == Nothing then "-" else show $ fromJust c
    shift isShift = if isShift then "\t" else "" 
    
    foldcch (CC {cc_system, cc_name, cc_param}) [] = [(cc_system, [(cc_name, cc_param)])]
    foldcch (CC {cc_system, cc_name, cc_param}) xs@((hs, hccs):txs) = if cc_system == hs then (hs, (cc_name,cc_param):hccs):txs 
        else (cc_system, [(cc_name,cc_param)]):xs
    foldcch _ _ = error "Function can be applied only for Communication Channels"
    
    fcch (s, cchs) = map (filter (/='"')) $ ["+" ++ show s] ++ map (\(cc, (t, at))->"\t" ++ (show cc) ++ " " ++ (show t) ++ " " ++ (show at)) cchs
